home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / aliencomp.lisp < prev    next >
Encoding:
Text File  |  1992-05-19  |  23.0 KB  |  702 lines
  1. ;;; -*- Log: C.Log; Package: C -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: aliencomp.lisp,v 1.21 92/03/22 23:47:05 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains transforms and other stuff used to compile Alien
  15. ;;; operations.
  16. ;;;
  17. ;;; Rewritten once again, this time by William Lott and Rob MacLachlan.
  18. ;;;
  19. (in-package "C")
  20. (use-package "ALIEN")
  21. (use-package "SYSTEM")
  22.  
  23. (export '(%alien-funcall))
  24.  
  25.  
  26. ;;;; defknowns
  27.  
  28. (defknown %sap-alien (system-area-pointer alien-type) alien-value
  29.   (flushable movable))
  30. (defknown alien-sap (alien-value) system-area-pointer
  31.   (flushable movable))
  32.  
  33. (defknown slot (alien-value symbol) t
  34.   (flushable recursive))
  35. (defknown %set-slot (alien-value symbol t) t
  36.   (recursive))
  37. (defknown %slot-addr (alien-value symbol) (alien (* t))
  38.   (flushable movable recursive))
  39.  
  40. (defknown deref (alien-value &rest index) t
  41.   (flushable))
  42. (defknown %set-deref (alien-value t &rest index) t
  43.   ())
  44. (defknown %deref-addr (alien-value &rest index) (alien (* t))
  45.   (flushable movable))
  46.  
  47. (defknown %heap-alien (heap-alien-info) t
  48.   (flushable))
  49. (defknown %set-heap-alien (heap-alien-info t) t
  50.   ())
  51. (defknown %heap-alien-addr (heap-alien-info) (alien (* t))
  52.   (flushable movable))
  53.  
  54. (defknown make-local-alien (local-alien-info) t
  55.   ())
  56. (defknown note-local-alien-type (local-alien-info t) null
  57.   ())
  58. (defknown local-alien (local-alien-info t) t
  59.   (flushable))
  60. (defknown %local-alien-forced-to-memory-p (local-alien-info) (member t nil)
  61.   (movable))
  62. (defknown %set-local-alien (local-alien-info t t) t
  63.   ())
  64. (defknown %local-alien-addr (local-alien-info t) (alien (* t))
  65.   (flushable movable))
  66. (defknown dispose-local-alien (local-alien-info t) t
  67.   ())
  68.  
  69. (defknown %cast (alien-value alien-type) alien
  70.   (flushable movable))
  71.  
  72. (defknown naturalize (t alien-type) alien
  73.   (flushable movable))
  74. (defknown deport (alien alien-type) t
  75.   (flushable movable))
  76. (defknown extract-alien-value (system-area-pointer index alien-type) t
  77.   (flushable))
  78. (defknown deposit-alien-value (system-area-pointer index alien-type t) t
  79.   ())
  80.  
  81. (defknown alien-funcall (alien-value &rest *) *
  82.   (any recursive))
  83. (defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
  84.  
  85.  
  86. ;;;; Cosmetic transforms.
  87.  
  88. (deftransform slot ((object slot)
  89.             ((alien (* t)) symbol))
  90.   '(slot (deref object) slot))
  91.  
  92. (deftransform %set-slot ((object slot value)
  93.              ((alien (* t)) symbol t))
  94.   '(%set-slot (deref object) slot value))
  95.  
  96. (deftransform %slot-addr ((object slot)
  97.               ((alien (* t)) symbol))
  98.   '(%slot-addr (deref object) slot))
  99.  
  100.  
  101. ;;;; SLOT support
  102.  
  103. (defun find-slot-offset-and-type (alien slot)
  104.   (unless (constant-continuation-p slot)
  105.     (give-up "Slot is not constant, so cannot open code access."))
  106.   (let ((type (continuation-type alien)))
  107.     (unless (alien-type-type-p type)
  108.       (give-up))
  109.     (let ((alien-type (alien-type-type-alien-type type)))
  110.       (unless (alien-record-type-p alien-type)
  111.     (give-up))
  112.       (let* ((slot-name (continuation-value slot))
  113.          (field (find slot-name (alien-record-type-fields alien-type)
  114.               :key #'alien-record-field-name)))
  115.     (unless field
  116.       (abort-transform "~S doesn't have a slot named ~S" alien slot-name))
  117.     (values (alien-record-field-offset field)
  118.         (alien-record-field-type field))))))
  119.  
  120. #+nil ;; Shouldn't be necessary.
  121. (defoptimizer (slot derive-type) ((alien slot))
  122.   (block nil
  123.     (catch 'give-up
  124.       (multiple-value-bind (slot-offset slot-type)
  125.                (find-slot-offset-and-type alien slot)
  126.     (declare (ignore slot-offset))
  127.     (return (make-alien-type-type slot-type))))
  128.     *wild-type*))
  129.  
  130. (deftransform slot ((alien slot) * * :important t)
  131.   (multiple-value-bind (slot-offset slot-type)
  132.                (find-slot-offset-and-type alien slot)
  133.     `(extract-alien-value (alien-sap alien)
  134.               ,slot-offset
  135.               ',slot-type)))
  136.  
  137. #+nil ;; ### But what about coersions?
  138. (defoptimizer (%set-slot derive-type) ((alien slot value))
  139.   (block nil
  140.     (catch 'give-up
  141.       (multiple-value-bind (slot-offset slot-type)
  142.                (find-slot-offset-and-type alien slot)
  143.     (declare (ignore slot-offset))
  144.     (let ((type (make-alien-type-type slot-type)))
  145.       (assert-continuation-type value type)
  146.       (return type))))
  147.     *wild-type*))
  148.  
  149. (deftransform %set-slot ((alien slot value) * * :important t)
  150.   (multiple-value-bind (slot-offset slot-type)
  151.                (find-slot-offset-and-type alien slot)
  152.     `(deposit-alien-value (alien-sap alien)
  153.               ,slot-offset
  154.               ',slot-type
  155.               value)))
  156.  
  157. (defoptimizer (%slot-addr derive-type) ((alien slot))
  158.   (block nil
  159.     (catch 'give-up
  160.       (multiple-value-bind (slot-offset slot-type)
  161.                (find-slot-offset-and-type alien slot)
  162.     (declare (ignore slot-offset))
  163.     (return (make-alien-type-type
  164.          (make-alien-pointer-type :to slot-type)))))
  165.     *wild-type*))
  166.  
  167. (deftransform %slot-addr ((alien slot) * * :important t)
  168.   (multiple-value-bind (slot-offset slot-type)
  169.                (find-slot-offset-and-type alien slot)
  170.     `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset vm:byte-bits))
  171.          ',(make-alien-pointer-type :to slot-type))))
  172.  
  173.  
  174.  
  175. ;;;; DEREF support.
  176.  
  177. (defun find-deref-alien-type (alien)
  178.   (let ((alien-type (continuation-type alien)))
  179.     (unless (alien-type-type-p alien-type)
  180.       (give-up))
  181.     (let ((alien-type (alien-type-type-alien-type alien-type)))
  182.       (if (alien-type-p alien-type)
  183.       alien-type
  184.       (give-up)))))
  185.  
  186. (defun find-deref-element-type (alien)
  187.   (let ((alien-type (find-deref-alien-type alien)))
  188.     (typecase alien-type
  189.       (alien-pointer-type
  190.        (alien-pointer-type-to alien-type))
  191.       (alien-array-type
  192.        (alien-array-type-element-type alien-type))
  193.       (t
  194.        (give-up)))))
  195.  
  196. (defun compute-deref-guts (alien indices)
  197.   (let ((alien-type (find-deref-alien-type alien)))
  198.     (typecase alien-type
  199.       (alien-pointer-type
  200.        (when (cdr indices)
  201.      (abort-transform "Too many indices for pointer deref: ~D"
  202.               (length indices)))
  203.        (let ((element-type (alien-pointer-type-to alien-type)))
  204.      (if indices
  205.          (let ((bits (alien-type-bits element-type))
  206.            (alignment (alien-type-alignment element-type)))
  207.            (unless bits
  208.          (abort-transform "Unknown element size."))
  209.            (unless alignment
  210.          (abort-transform "Unknown element alignment."))
  211.            (values '(offset)
  212.                `(* offset
  213.                ,(align-offset bits alignment))
  214.                element-type))
  215.          (values nil 0 element-type))))
  216.       (alien-array-type
  217.        (let* ((element-type (alien-array-type-element-type alien-type))
  218.           (bits (alien-type-bits element-type))
  219.           (alignment (alien-type-alignment element-type))
  220.           (dims (alien-array-type-dimensions alien-type)))
  221.      (unless (= (length indices) (length dims))
  222.        (give-up "Incorrect number of indices."))
  223.      (unless bits
  224.        (give-up "Element size unknown."))
  225.      (unless alignment
  226.        (give-up "Element alignment unknown."))
  227.      (if (null dims)
  228.          (values nil 0 element-type)
  229.          (let* ((arg (gensym))
  230.             (args (list arg))
  231.             (offsetexpr arg))
  232.            (dolist (dim (cdr dims))
  233.          (let ((arg (gensym)))
  234.            (push arg args)
  235.            (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
  236.            (values (reverse args)
  237.                `(* ,offsetexpr
  238.                ,(align-offset bits alignment))
  239.                element-type)))))
  240.       (t
  241.        (abort-transform "~S not either a pointer or array type."
  242.             alien-type)))))
  243.  
  244.  
  245. #+nil ;; Shouldn't be necessary.
  246. (defoptimizer (deref derive-type) ((alien &rest noise))
  247.   (declare (ignore noise))
  248.   (block nil
  249.     (catch 'give-up
  250.       (return (make-alien-type-type (find-deref-element-type alien))))
  251.     *wild-type*))
  252.  
  253. (deftransform deref ((alien &rest indices) * * :important t)
  254.   (multiple-value-bind
  255.       (indices-args offset-expr element-type)
  256.       (compute-deref-guts alien indices)
  257.     `(lambda (alien ,@indices-args)
  258.        (extract-alien-value (alien-sap alien)
  259.                 ,offset-expr
  260.                 ',element-type))))
  261.  
  262. #+nil ;; ### Again, the value might be coerced.
  263. (defoptimizer (%set-deref derive-type) ((alien value &rest noise))
  264.   (declare (ignore noise))
  265.   (block nil
  266.     (catch 'give-up
  267.       (let ((type (make-alien-type-type
  268.            (make-alien-pointer-type
  269.             :to (find-deref-element-type alien)))))
  270.     (assert-continuation-type value type)
  271.     (return type)))
  272.     *wild-type*))
  273.  
  274. (deftransform %set-deref ((alien value &rest indices) * * :important t)
  275.   (multiple-value-bind
  276.       (indices-args offset-expr element-type)
  277.       (compute-deref-guts alien indices)
  278.     `(lambda (alien value ,@indices-args)
  279.        (deposit-alien-value (alien-sap alien)
  280.                 ,offset-expr
  281.                 ',element-type
  282.                 value))))
  283.   
  284. (defoptimizer (%deref-addr derive-type) ((alien &rest noise))
  285.   (declare (ignore noise))
  286.   (block nil
  287.     (catch 'give-up
  288.       (return (make-alien-type-type
  289.            (make-alien-pointer-type
  290.         :to (find-deref-element-type alien)))))
  291.     *wild-type*))
  292.  
  293. (deftransform %deref-addr ((alien &rest indices) * * :important t)
  294.   (multiple-value-bind
  295.       (indices-args offset-expr element-type)
  296.       (compute-deref-guts alien indices)
  297.     `(lambda (alien ,@indices-args)
  298.        (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr vm:byte-bits))
  299.            ',(make-alien-pointer-type :to element-type)))))
  300.  
  301.  
  302.  
  303. ;;;; Heap Alien Support.
  304.  
  305. (defun heap-alien-sap-and-type (info)
  306.   (unless (constant-continuation-p info)
  307.     (give-up "Info not constant; can't open code."))
  308.   (let ((info (continuation-value info)))
  309.     (values (heap-alien-info-sap-form info)
  310.         (heap-alien-info-type info))))
  311.  
  312. #+nil ;; Shouldn't be necessary.
  313. (defoptimizer (%heap-alien derive-type) ((info))
  314.   (block nil
  315.     (catch 'give-up
  316.       (multiple-value-bind (sap type)
  317.                (heap-alien-sap-and-type info)
  318.     (declare (ignore sap))
  319.     (return (make-alien-type-type type))))
  320.     *wild-type*))
  321.  
  322. (deftransform %heap-alien ((info) * * :important t)
  323.   (multiple-value-bind (sap type)
  324.                (heap-alien-sap-and-type info)
  325.     `(extract-alien-value ,sap 0 ',type)))
  326.  
  327. #+nil ;; ### Again, deposit value might change the type.
  328. (defoptimizer (%set-heap-alien derive-type) ((info value))
  329.   (block nil
  330.     (catch 'give-up
  331.       (multiple-value-bind (sap type)
  332.                (heap-alien-sap-and-type info)
  333.     (declare (ignore sap))
  334.     (let ((type (make-alien-type-type type)))
  335.       (assert-continuation-type value type)
  336.       (return type))))
  337.     *wild-type*))
  338.  
  339. (deftransform %set-heap-alien ((info value) (heap-alien-info *) * :important t)
  340.   (multiple-value-bind (sap type)
  341.                (heap-alien-sap-and-type info)
  342.     `(deposit-alien-value ,sap 0 ',type value)))
  343.  
  344. (defoptimizer (%heap-alien-addr derive-type) ((info))
  345.   (block nil
  346.     (catch 'give-up
  347.       (multiple-value-bind (sap type)
  348.                (heap-alien-sap-and-type info)
  349.     (declare (ignore sap))
  350.     (return (make-alien-type-type (make-alien-pointer-type :to type)))))
  351.     *wild-type*))
  352.  
  353. (deftransform %heap-alien-addr ((info) * * :important t)
  354.   (multiple-value-bind (sap type)
  355.                (heap-alien-sap-and-type info)
  356.     `(%sap-alien ,sap ',type)))
  357.  
  358.  
  359. ;;;; Local (stack or register) alien support.
  360.  
  361. (deftransform make-local-alien ((info) * * :important t)
  362.   (unless (constant-continuation-p info)
  363.     (abort-transform "Local Alien Info isn't constant?"))
  364.   (let* ((info (continuation-value info))
  365.      (alien-type (local-alien-info-type info))
  366.      (bits (alien-type-bits alien-type)))
  367.     (unless bits
  368.       (abort-transform "Unknown size: ~S" (unparse-alien-type alien-type)))
  369.     (if (local-alien-info-force-to-memory-p info)
  370.     `(truly-the system-area-pointer
  371.             (%primitive alloc-number-stack-space
  372.                 ,(ceiling (alien-type-bits alien-type)
  373.                       vm:byte-bits)))
  374.     (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
  375.            (alien-rep-type (specifier-type alien-rep-type-spec)))
  376.       (cond ((csubtypep (specifier-type 'system-area-pointer)
  377.                 alien-rep-type)
  378.          '(int-sap 0))
  379.         ((ctypep 0 alien-rep-type) 0)
  380.         ((ctypep 0.0f0 alien-rep-type) 0.0f0)
  381.         ((ctypep 0.0d0 alien-rep-type) 0.0d0)
  382.         (t
  383.          (compiler-error
  384.           "Aliens of type ~S cannot be represented immediately."
  385.           (unparse-alien-type alien-type))))))))
  386.  
  387. (deftransform note-local-alien-type ((info var) * * :important t)
  388.   (unless (constant-continuation-p info)
  389.     (abort-transform "Local Alien Info isn't constant?"))
  390.   (let ((info (continuation-value info)))
  391.     (unless (local-alien-info-force-to-memory-p info)
  392.       (let ((var-node (continuation-use var)))
  393.     (when (ref-p var-node)
  394.       (propagate-to-refs (ref-leaf var-node)
  395.                  (specifier-type
  396.                   (compute-alien-rep-type
  397.                    (local-alien-info-type info))))))))
  398.   'nil)
  399.  
  400. (deftransform local-alien ((info var) * * :important t)
  401.   (unless (constant-continuation-p info)
  402.     (abort-transform "Local Alien Info isn't constant?"))
  403.   (let* ((info (continuation-value info))
  404.      (alien-type (local-alien-info-type info)))
  405.     (if (local-alien-info-force-to-memory-p info)
  406.     `(extract-alien-value var 0 ',alien-type)
  407.     `(naturalize var ',alien-type))))
  408.  
  409. (deftransform %local-alien-forced-to-memory-p ((info) * * :important t)
  410.   (unless (constant-continuation-p info)
  411.     (abort-transform "Local Alien Info isn't constant?"))
  412.   (let ((info (continuation-value info)))
  413.     (local-alien-info-force-to-memory-p info)))
  414.  
  415. (deftransform %set-local-alien ((info var value) * * :important t)
  416.   (unless (constant-continuation-p info)
  417.     (abort-transform "Local Alien Info isn't constant?"))
  418.   (let* ((info (continuation-value info))
  419.      (alien-type (local-alien-info-type info)))
  420.     (if (local-alien-info-force-to-memory-p info)
  421.     `(deposit-alien-value var 0 ',alien-type value)
  422.     '(error "This should be dead-code eleminated."))))
  423.  
  424. (defoptimizer (%local-alien-addr derive-type) ((info var))
  425.   (if (constant-continuation-p info)
  426.       (let* ((info (continuation-value info))
  427.          (alien-type (local-alien-info-type info)))
  428.     (make-alien-type-type (make-alien-pointer-type :to alien-type)))
  429.       *wild-type*))
  430.  
  431. (deftransform %local-alien-addr ((info var) * * :important t)
  432.   (unless (constant-continuation-p info)
  433.     (abort-transform "Local Alien Info isn't constant?"))
  434.   (let* ((info (continuation-value info))
  435.      (alien-type (local-alien-info-type info)))
  436.     (if (local-alien-info-force-to-memory-p info)
  437.     `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
  438.     (error "This shouldn't happen."))))
  439.  
  440. (deftransform dispose-local-alien ((info var) * * :important t)
  441.   (unless (constant-continuation-p info)
  442.     (abort-transform "Local Alien Info isn't constant?"))
  443.   (let* ((info (continuation-value info))
  444.      (alien-type (local-alien-info-type info)))
  445.     (if (local-alien-info-force-to-memory-p info)
  446.     `(%primitive dealloc-number-stack-space
  447.              ,(ceiling (alien-type-bits alien-type)
  448.                    vm:byte-bits))
  449.     nil)))
  450.  
  451.  
  452. ;;;; %CAST
  453.  
  454. (defoptimizer (%cast derive-type) ((alien type))
  455.   (or (when (constant-continuation-p type)
  456.     (let ((alien-type (continuation-value type)))
  457.       (when (alien-type-p alien-type)
  458.         (make-alien-type-type alien-type))))
  459.       *wild-type*))
  460.  
  461. (deftransform %cast ((alien target-type) * * :important t)
  462.   (unless (constant-continuation-p target-type)
  463.     (give-up "Alien type not constant; cannot open code."))
  464.   (let ((target-type (continuation-value target-type)))
  465.     (cond ((or (alien-pointer-type-p target-type)
  466.            (alien-array-type-p target-type)
  467.            (alien-function-type-p target-type))
  468.        `(naturalize (alien-sap alien) ',target-type))
  469.       (t
  470.        (abort-transform "Cannot cast to alien type ~S" target-type)))))
  471.  
  472.  
  473. ;;;; alien-sap, %sap-alien, %addr, etc
  474.  
  475. (deftransform alien-sap ((alien) * * :important t)
  476.   (let ((alien-node (continuation-use alien)))
  477.     (typecase alien-node
  478.       (combination
  479.        (extract-function-args alien '%sap-alien 2)
  480.        '(lambda (sap type)
  481.       (declare (ignore type))
  482.       sap))
  483.       (t
  484.        (give-up)))))
  485.  
  486. (defoptimizer (%sap-alien derive-type) ((sap type))
  487.   (declare (ignore sap))
  488.   (if (constant-continuation-p type)
  489.       (make-alien-type-type (continuation-value type))
  490.       *wild-type*))
  491.  
  492. (deftransform %sap-alien ((sap type) * * :important t)
  493.   (give-up "Could not optimize away %SAP-ALIEN: forced to do runtime ~@
  494.         allocation of alien-value structure."))
  495.  
  496.  
  497.  
  498. ;;;; Extract/deposit magic
  499.  
  500. (eval-when (compile eval)
  501.   (defmacro compiler-error-if-loses (form)
  502.     `(handler-case
  503.      ,form
  504.        (error (condition)
  505.      (compiler-error "~A" condition)))))
  506.  
  507. (deftransform naturalize ((object type) * * :important t)
  508.   (unless (constant-continuation-p type)
  509.     (give-up "Type not constant at compile time; can't open code."))
  510.   (compiler-error-if-loses
  511.    (compute-naturalize-lambda (continuation-value type))))
  512.  
  513. (deftransform deport ((alien type) * * :important t)
  514.   (unless (constant-continuation-p type)
  515.     (give-up "Type not constant at compile time; can't open code."))
  516.   (compiler-error-if-loses
  517.    (compute-deport-lambda (continuation-value type))))
  518.  
  519. (deftransform extract-alien-value ((sap offset type) * * :important t)
  520.   (unless (constant-continuation-p type)
  521.     (give-up "Type not constant at compile time; can't open code."))
  522.   (compiler-error-if-loses
  523.    (compute-extract-lambda (continuation-value type))))
  524.  
  525. (deftransform deposit-alien-value ((sap offset type value) * * :important t)
  526.   (unless (constant-continuation-p type)
  527.     (give-up "Type not constant at compile time; can't open code."))
  528.   (compiler-error-if-loses
  529.    (compute-deposit-lambda (continuation-value type))))
  530.  
  531.  
  532. ;;;; Hack to clean up divisions.
  533.  
  534. (defun count-low-order-zeros (thing)
  535.   (typecase thing
  536.     (continuation
  537.      (if (constant-continuation-p thing)
  538.      (count-low-order-zeros (continuation-value thing))
  539.      (count-low-order-zeros (continuation-use thing))))
  540.     (combination
  541.      (case (continuation-function-name (combination-fun thing))
  542.        ((+ -)
  543.     (let ((min most-positive-fixnum)
  544.           (itype (specifier-type 'integer)))
  545.       (dolist (arg (combination-args thing) min)
  546.         (if (csubtypep (continuation-type arg) itype)
  547.         (setf min (min min (count-low-order-zeros arg)))
  548.         (return 0)))))
  549.        (*
  550.     (let ((result 0)
  551.           (itype (specifier-type 'integer)))
  552.       (dolist (arg (combination-args thing) result)
  553.         (if (csubtypep (continuation-type arg) itype)
  554.         (setf result (+ result (count-low-order-zeros arg)))
  555.         (return 0)))))
  556.        (ash
  557.     (let ((args (combination-args thing)))
  558.       (if (= (length args) 2)
  559.           (let ((amount (second args)))
  560.         (if (constant-continuation-p amount)
  561.             (max (+ (count-low-order-zeros (first args))
  562.                 (continuation-value amount))
  563.              0)
  564.             0))
  565.           0)))
  566.        (t
  567.     0)))
  568.     (integer
  569.      (if (zerop thing)
  570.      most-positive-fixnum
  571.      (do ((result 0 (1+ result))
  572.           (num thing (ash num -1)))
  573.          ((logbitp 0 num) result))))
  574.     (t
  575.      0)))
  576.  
  577. (deftransform / ((numerator denominator) (integer integer))
  578.   (unless (constant-continuation-p denominator)
  579.     (give-up))
  580.   (let* ((denominator (continuation-value denominator))
  581.      (bits (1- (integer-length denominator))))
  582.     (unless (= (ash 1 bits) denominator)
  583.       (give-up))
  584.     (let ((alignment (count-low-order-zeros numerator)))
  585.       (unless (>= alignment bits)
  586.     (give-up))
  587.       `(ash numerator ,(- bits)))))
  588.  
  589. (deftransform ash ((value amount))
  590.   (let ((value-node (continuation-use value)))
  591.     (unless (and (combination-p value-node)
  592.          (eq (continuation-function-name (combination-fun value-node))
  593.              'ash))
  594.       (give-up))
  595.     (let ((inside-args (combination-args value-node)))
  596.       (unless (= (length inside-args) 2)
  597.     (give-up))
  598.       (let ((inside-amount (second inside-args)))
  599.     (unless (and (constant-continuation-p inside-amount)
  600.              (not (minusp (continuation-value inside-amount))))
  601.       (give-up)))))
  602.   (extract-function-args value 'ash 2)
  603.   '(lambda (value amount1 amount2)
  604.      (ash value (+ amount1 amount2))))
  605.  
  606.  
  607. ;;;; ALIEN-FUNCALL support.
  608.  
  609. (deftransform alien-funcall ((function &rest args)
  610.                  ((alien (* t)) &rest *) *
  611.                  :important t)
  612.   (let ((names (loop repeat (length args) collect (gensym))))
  613.     `(lambda (function ,@names)
  614.        (alien-funcall (deref function) ,@names))))
  615.  
  616. (deftransform alien-funcall ((function &rest args) * * :important t)
  617.   (let ((type (continuation-type function)))
  618.     (unless (alien-type-type-p type)
  619.       (give-up "Can't tell function type at compile time."))
  620.     (let ((alien-type (alien-type-type-alien-type type)))
  621.       (unless (alien-function-type-p alien-type)
  622.     (give-up))
  623.       (let ((arg-types (alien-function-type-arg-types alien-type)))
  624.     (unless (= (length args) (length arg-types))
  625.       (abort-transform "Wrong number of arguments.  Expected ~D, got ~D."
  626.                (length arg-types) (length args)))
  627.     (collect ((params) (deports))
  628.       (dolist (arg-type arg-types)
  629.         (let ((param (gensym)))
  630.           (params param)
  631.           (deports `(deport ,param ',arg-type))))
  632.       (let ((return-type (alien-function-type-result-type alien-type))
  633.         (body `(%alien-funcall (deport function ',alien-type)
  634.                        ',alien-type
  635.                        ,@(deports))))
  636.         (if (alien-values-type-p return-type)
  637.         (collect ((temps) (results))
  638.           (dolist (type (alien-values-type-values return-type))
  639.             (let ((temp (gensym)))
  640.               (temps temp)
  641.               (results `(naturalize ,temp ',type))))
  642.           (setf body
  643.             `(multiple-value-bind
  644.                  ,(temps)
  645.                  ,body
  646.                (values ,@(results)))))
  647.         (setf body `(naturalize ,body ',return-type)))
  648.         `(lambda (function ,@(params))
  649.            ,body)))))))
  650.  
  651. (defoptimizer (%alien-funcall derive-type) ((function type &rest args))
  652.   (declare (ignore function args))
  653.   (unless (constant-continuation-p type)
  654.     (error "Something is broken."))
  655.   (let ((type (continuation-value type)))
  656.     (unless (alien-function-type-p type)
  657.       (error "Something is broken."))
  658.     (specifier-type
  659.      (compute-alien-rep-type
  660.       (alien-function-type-result-type type)))))
  661.  
  662. (defoptimizer (%alien-funcall ltn-annotate)
  663.           ((function type &rest args) node policy)
  664.   (setf (basic-combination-info node) :funny)
  665.   (setf (node-tail-p node) nil)
  666.   (annotate-ordinary-continuation function policy)
  667.   (dolist (arg args)
  668.     (annotate-ordinary-continuation arg policy)))
  669.  
  670. (defoptimizer (%alien-funcall ir2-convert)
  671.           ((function type &rest args) call block)
  672.   (let ((type (if (constant-continuation-p type)
  673.           (continuation-value type)
  674.           (error "Something is broken.")))
  675.     (cont (node-cont call))
  676.     (args args))
  677.     (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
  678.              (make-call-out-tns type)
  679.       (vop alloc-number-stack-space call block stack-frame-size nsp)
  680.       (dolist (tn arg-tns)
  681.     (let* ((arg (pop args))
  682.            (sc (tn-sc tn))
  683.            (scn (sc-number sc))
  684.            (temp-tn (make-representation-tn (tn-primitive-type tn) scn))
  685.            (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
  686.       (assert arg)
  687.       (assert (= (length move-arg-vops) 1) ()
  688.           "No unique move-arg-vop for moves in SC ~S."
  689.           (sc-name sc))
  690.       (emit-move call block (continuation-tn call block arg) temp-tn)
  691.       (emit-move-arg-template call block (first move-arg-vops)
  692.                   temp-tn nsp tn)))
  693.       (assert (null args))
  694.       (unless (listp result-tns)
  695.     (setf result-tns (list result-tns)))
  696.       (vop* call-out call block
  697.         ((continuation-tn call block function)
  698.          (reference-tn-list arg-tns nil))
  699.         ((reference-tn-list result-tns t)))
  700.       (vop dealloc-number-stack-space call block stack-frame-size)
  701.       (move-continuation-result call block result-tns cont))))
  702.